home *** CD-ROM | disk | FTP | other *** search
/ Whiteline: Alpha / Whiteline Alpha.iso / tools / prtfolio / port_2 / graph / wuerfel.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1994-09-22  |  1.8 KB  |  95 lines
  1. program wuerfel;
  2.  
  3. uses
  4.   dos,pfcrt,pfgraph;
  5.  
  6. const
  7.   muster  : fillpatterntype =  ($80,$00,$08,$00,$80,$00,$08,$00);
  8.   xyco    : array[0..13] of byte =
  9.               (30,30,15,15,15,30,15,45,45,45,45,30,45,15);
  10.   augnr   : array[1..6] of byte =
  11.               ($1,$12,$13,$5a,$5b,$7e);
  12.  
  13.  
  14. var
  15.   ch         : char;
  16.   sprite     : array[0..90] of byte;
  17.   lsprite    : array[0..90] of byte;
  18.   xofs,yofs,
  19.   x,y        : integer;
  20.   z          : byte;
  21.  
  22. procedure Screen; external;
  23. {$l screen.obj}
  24.  
  25. { Die Datei SCREEN.OBJ ist die mittels BINOBJ (Utility von T. Pascal)
  26.   konvertierte Datei BILD2.APF aus dem Verzeichnis PICTURES }
  27.  
  28.  
  29. function RolB(zahl,anz : byte) : byte;
  30.   INLINE($59/$58/$D2/$C0);
  31.  
  32.  
  33. procedure SetWuerfel(augen : byte);
  34. var
  35.   i,b  : byte;
  36. begin
  37.   b:= augnr[augen];
  38.   b:= rolb(b,2);
  39.   for i:= 6 downto 0 do
  40.   begin
  41.     if odd(b) then
  42.       putimage(xyco[i*2]+xofs,xyco[(i*2)+1]+yofs,sprite);
  43.     b:= rolb(b,1);
  44.   end;
  45. end;
  46.  
  47. procedure DelAugen;
  48. var
  49.   i   : byte;
  50.   x,y : integer;
  51. begin
  52.   for i:= 6 downto 0 do
  53.   begin
  54.     x:= xyco[i*2]+xofs;
  55.     y:= xyco[(i*2)+1]+yofs;
  56.     putimage(x,y,lsprite);
  57.     FillPattern(x,y,x+8,y+8,muster);
  58.   end;
  59. end;
  60.  
  61. begin
  62.   randomize;
  63.   xofs:= 10;
  64.   yofs:= -2;
  65.   initgraph;
  66.   getimage(0,0,8,8,lsprite);
  67.   aktf:= 1;
  68.   circle(4,4,4);
  69.   floodfill(4,4,1);
  70.   aktf:= 0;
  71.   circle(4,4,2);
  72.   getimage(0,0,8,8,sprite);
  73.   putimage(0,0,lsprite);
  74.   showsobj(@screen);
  75.   ch:= readkey;
  76.   initgraph;
  77.   aktf:= 1;
  78.   x:= xofs+1;
  79.   y:= yofs+7;
  80.   FillPattern(x,y,x+64,y+55,muster);
  81.   rectangle(x,y,x+64,y+55);
  82.   SetFont(5);
  83.   outtextxy(xofs+82,4,'The Dice');
  84.   SetFont(1);
  85.   outtextxy(xofs+82,45,'Weiterwuerfeln mit Taste');
  86.   outtextxy(xofs+82,53,'ESC = Ende');
  87.   repeat
  88.     z:= random(6)+1;
  89.     setwuerfel(z);
  90.     ch:= readkey;
  91.     delaugen;
  92.   until ch= #27;
  93.   closegraph;
  94. end.
  95. ə